Agent--------------
Option Public
Option Declare
Use "ManejoAttachments"
Use "enviarCorreoHTML"
Sub Initialize
Dim destino As Variant
Dim html As String
Dim mensaje As String
Dim subj As String
Dim archivo As String
Dim ruta As String
Dim copyTo(2) As Variant
archivo = "\Prueba.txt"
subj = "Notificacion de prueba con anexo"
mensaje = "Esto es una prueba"
destino = "CN=Contacto Lotus Sistemas SII/OU=Operacion/O=Prebel"
copyTo(0) = "x1@com.co"
copyTo(1) = "x2@com.co"
copyTo(2) = "x3@com.co"
ruta = "C:\Domino\data\domino\html\"
MsgBox "Voy a enviar"
'(strForm, sendTo, copyTo, blindCopyTo, subject, strBodyAtt, strStyle, strBody, principal, rutaInconsis, archivo)
Call enviarCorreoHTMLAnexos("memo", destino, copyTo, "", subj, "", "", mensaje, "Preuba", ruta, archivo)
End Sub
Script Library "EnviarCorreoHTML"----------------------------------------
Use "ManejoAttachments"
Public Sub enviarCorreoHTMLAnexos(strForm As String, sendTo As Variant, copyTo As Variant, blindCopyTo As Variant, subject As String, strBodyAtt As String, strStyle As String, strBody As String, principal As String, rutaInconsis As String, archivo As string)
On Error GoTo label
'Declare Variables
Dim s As New NotesSession
Dim db As NotesDatabase
Dim body As NotesMIMEEntity
Dim stream As NotesStream
Dim rtitem As NotesRichTextItem
Set db = s.CurrentDatabase
'Capture the server name and filepath for use in URLs
Dim ServerName As New NotesName( db.Server )
'host = "http://" + ServerName.Common & ".imation.com"
s.ConvertMIME = False ' Do not convert MIME to rich text
Set stream = s.CreateStream
'Begin creating the message doc to send
Dim message As New NotesDocument (db)
message.Form=strForm
'Basic profile of email
message.Subject = subject
message.SendTo = sendTo
message.copyTo = copyTo
message.blindCopyTo = blindCopyTo
message.principal = principal
'Set rtitem = New NotesRichTextItem( message, "Body1" )
'--------Instancia de la clase para el manejo de archivos anexos-------
Dim objAtt As New ManejoAtt(message, rutaInconsis)
Call objAtt.AnexarArchivo("Body1", archivo)
'----------------------------------------------------------------------
Set body = message.CreateMIMEEntity
message.RecNoOutOfOffice = "1" 'Set it so out of office agents don't reply to the message
' Open the HTML (Title doesn't matter since it doesn't appear anywhere)
Call stream.WriteText ("<html><head><title>" + subject + "</title>")
' BEGIN: Inline Stylesheet
Call stream.WriteText (strStyle)
'Msgbox strStyle
' END: Inline Stylesheet
Call stream.WriteText ({</head>})
Call stream.WriteText ({<body } + strBodyAtt + {>})
' BEGIN: HTML body
Call stream.WriteText (strBody)
' END: HTML body
' Close the HTML
Call stream.WriteText ({</body></html>})
' Ensure the MIME content will be recognized as HTML (Must be after the stream is written)
Call body.SetContentFromText (stream, "text/html;charset=iso-8859-1", ENC_NONE)
'
'Send the email
Call message.Send (False)
s.ConvertMIME = True ' Restore conversion
Exit Sub
label:
MessageBox "Error enviarCorreoHTMLAnexos() - libreria enviarCorreoHTML, Error: "& Str(Err) & " en la línea " & CStr(Erl()) & ":" & Error$
Exit Sub
End Sub
Function bodyatt1() As String
bodyatt1= {text="#666666" bgcolor="#FFFFFF" leftmargin="0" topmargin="0" marginheight="0" marginwidth="0"}
End Function
Public Sub enviarCorreoHTML1(strForm As String, sendTo As Variant, copyTo As Variant, blindCopyTo As Variant, subject As String, strBodyAtt As String, strStyle As String, strBody As String, principal As String)
'Declare Variables
Dim s As New NotesSession
Dim db As NotesDatabase
Dim body As NotesMIMEEntity
Dim stream As NotesStream
Set db = s.CurrentDatabase
'Capture the server name and filepath for use in URLs
Dim ServerName As New NotesName( db.Server )
'host = "http://" + ServerName.Common & ".imation.com"
s.ConvertMIME = False ' Do not convert MIME to rich text
Set stream = s.CreateStream
'Begin creating the message doc to send
Dim message As New NotesDocument (db)
message.Form=strForm
Set body = message.CreateMIMEEntity
'Basic profile of email
message.Subject = subject
message.SendTo = sendTo
message.copyTo = copyTo
message.blindCopyTo = blindCopyTo
message.principal = principal
message.RecNoOutOfOffice = "1" 'Set it so out of office agents don't reply to the message
' Open the HTML (Title doesn't matter since it doesn't appear anywhere)
Call stream.WriteText ("<html><head><title>" + subject + "</title>")
' BEGIN: Inline Stylesheet
Call stream.WriteText (strStyle)
'Msgbox strStyle
' END: Inline Stylesheet
Call stream.WriteText ({</head>})
Call stream.WriteText ({<body } + strBodyAtt + {>})
' BEGIN: HTML body
Call stream.WriteText (strBody)
' END: HTML body
' Close the HTML
Call stream.WriteText ({</body></html>})
' Ensure the MIME content will be recognized as HTML (Must be after the stream is written)
Call body.SetContentFromText (stream, "text/html;charset=iso-8859-1", ENC_NONE)
'
'Send the email
Call message.Send (False)
s.ConvertMIME = True ' Restore conversion
End Sub
Function cuscosky() As String
cuscosky = |
<style type="text/css">
<!--
/*
Cusco Sky table styles
written by Braulio Soncco http://www.buayacorp.com
*/
table, th, td {
border: 1px solid #D4E0EE;
border-collapse: collapse;
font-family: "Trebuchet MS", Arial, sans-serif;
color: #555;
}
caption {
font-size: 150%;
font-weight: bold;
margin: 5px;
}
td, th {
padding: 4px;
}
thead th {
text-align: left;
background: #E6EDF5;
color: #4F76A3;
font-size: 100% !important;
}
tbody th {
font-weight: bold;
}
tbody tr { background: #FCFDFE; }
tbody tr.odd { background: #F7F9FC; }
table a:link {
color: #718ABE;
text-decoration: underline;
}
table a:visited {
color: #718ABE;
text-decoration: underline;
}
table a:hover {
color: #718ABE;
text-decoration: underline !important;
}
tfoot th, tfoot td {
font-size: 85%;
}
-->
</style> |
End Function
Script Library "ManejoAttachments"---------------------------------------------------------------------------------------------
Option Public
Option Declare
Class ManejoAtt
ns As notessession
dbActual As NotesDatabase
object As NotesEmbeddedObject
rtitem As NotesRichTextItem
doc As notesdocument
ruta As String
'campo As String
'extCampo As String
rtitem1 As Variant
Sub new(ndConfg As NotesDocument, extRuta As String)
Set ns=New NotesSession
Set dbActual=ns.CurrentDatabase
Set doc = ndConfg
ruta = extRuta
End Sub
'========Metodo que extrae el archivo especificado de un documento de lotus===================
Sub ExtraerArchivo( extCampo, extArchivo )
On Error Goto ehExtraer
Set rtitem1 = doc.GetFirstItem( extCampo )
If ( rtitem1.Type = RICHTEXT ) Then
Forall o In rtitem1.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT ) Then
Call o.ExtractFile( ruta+extArchivo )
End If
End Forall
End If
Exit Sub
ehExtraer:
Print "Error metodo ExtraerArchivo " & Str(Err) & ": " & Error$
Msgbox "Error metodo ExtraerArchivo " & Str(Err) & ": " & Error$
End Sub
'===En caso de ser necesario, este metodo elimina del documento de lotus un archivo uqe se encuentre anexo en el====
Sub EliminarArchivoDoc(extCampo, extArchivo)
On Error Goto ehEliminarArchDoc
Set rtitem1 = doc.GetFirstItem( extCampo )
'Elimino el archivo del documento de configuración
Set object = rtitem1.GetEmbeddedObject( extArchivo )
Call object.Remove
Call doc.Save( True, True )
Exit Sub
ehEliminarArchDoc:
Print "Error metodo EliminarArchivoDoc " & Str(Err) & ": " & Error$
Msgbox "Error metodo EliminarArchivoDoc " & Str(Err) & ": " & Error$
End Sub
'======Este metodo anexa un archivo a un documento de lotus, desde una ruta del equipo
Sub AnexarArchivo(Campo, extArchivo)
On Error Goto ehAnexarArch
'anexo nuevamente el archivo al documento de configuracion ya actualizado
Set rtitem = New NotesRichTextItem( doc, Campo )
Set object = rtitem.EmbedObject ( EMBED_ATTACHMENT, "", ruta+extArchivo)
Call doc.Save( True, false )
Exit Sub
ehAnexarArch:
Print "Error metodo AnexarArchivo " & Str(Err) & ": " & Error$
Msgbox "Error metodo AnexarArchivo " & Str(Err) & ": " & Err & " en la línea " & CStr(Erl()) & " :" & Error$
End Sub
'===========Este metodo elimina el archivo especificado de una ruta del equipo===========
Sub EliminarArchivoDisco(extArchivo)
On Error Goto ehElimiarArchDisco
'Elimino los .xls que quedan en el c:
Dim pathName As String, fileName As String
pathName$ = ruta+extArchivo
MsgBox "AAAA "+pathName$
fileName$ = Dir$(pathName$, 0)
While fileName$ <> ""
MsgBox "XXXX " + fileName$
Kill ruta +"\"+ fileName$
fileName$ = Dir$()
Wend
Exit Sub
ehElimiarArchDisco:
Print "Error metodo ehElimiarArchDisco " & Str(Err) & ": " & Error$
Msgbox "Error metodo ehElimiarArchDisco55 " & Str(Err) & ": " & Error$
Msgbox "Error metodo ehElimiarArchDisco " & Str(Err) & ": " & Err
Msgbox "Línea del error: "+Cstr(Erl())
End Sub
'===========Este metodo elimina el archivo especificado de una ruta del equipo===========
Sub EliminarUnArchivoDisco(ruta)
On Error GoTo ehEliminarUnArchivoDisco
if ruta <> "" Then
MsgBox "ruta " + ruta
Kill ruta
End if
Exit Sub
ehEliminarUnArchivoDisco:
Print "Error metodo EliminarUnArchivoDisco " & Str(Err) & ": " & Error$
MsgBox "Error metodo EliminarUnArchivoDisco " & Str(Err) & ": " & Err
MsgBox "Línea del error: "+Cstr(Erl())
End Sub
End Class